home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / usenet / sources / volume89 / languags / siod.1 < prev    next >
Text File  |  1989-03-16  |  42KB  |  1,561 lines
  1. Path: xanth!nic.MR.NET!hal!cwjcc!mailrus!ulowell!page
  2. From: page@swan.ulowell.edu (Bob Page)
  3. Newsgroups: comp.sources.amiga
  4. Subject: v89i078:  siod - small lisp interpreter
  5. Message-ID: <12301@swan.ulowell.edu>
  6. Date: 16 Mar 89 20:16:56 GMT
  7. Organization: University of Lowell, Computer Science Dept.
  8. Lines: 1550
  9. Approved: page@swan.ulowell.edu
  10.  
  11. Submitted-by: gjc@bu-it.BU.EDU (George Carrette)
  12. Posting-number: Volume 89, Issue 78
  13. Archive-name: languages/siod.1
  14.  
  15. siod - Scheme In One Defun.  Siod is a very small scheme interpreter
  16. which can be used for short calculations or included as a command
  17. interpreter or extension/macro language in other applications.
  18.  
  19. [executable not supplied.  ..Bob]
  20.  
  21. #    This is a shell archive.
  22. #    Remove everything above and including the cut line.
  23. #    Then run the rest of the file through sh.
  24. #----cut here-----cut here-----cut here-----cut here----#
  25. #!/bin/sh
  26. # shar:    Shell Archiver
  27. #    Run the following text with /bin/sh to create:
  28. #    makefile
  29. #    siod.c
  30. #    siod.doc
  31. #    siod.n
  32. #    siod.scm
  33. # This archive created: Thu Mar 16 15:09:01 1989
  34. cat << \SHAR_EOF > makefile
  35. # Note: add the -f68881 flag if you are on a SUN III.
  36. siod:    siod.c
  37.     cc -O -o siod siod.c
  38. SHAR_EOF
  39. cat << \SHAR_EOF > siod.c
  40. /* Scheme In One Defun, but in C this time.
  41.    (c) Copyright 1988 George Carrette, gjc@bu-it.bu.edu
  42.    For demonstration purposes only.
  43.  
  44.    If your interests run to practical applications of symbolic programming
  45.    techniques, in LISP, Macsyma, C, or other language:
  46.  
  47.    Paradigm Associates Inc          Phone: 617-492-6079
  48.    29 Putnam Ave, Suite 6
  49.    Cambridge, MA 02138
  50.  
  51.    Release 1.0: 24-APR-88
  52.    Release 1.1: 25-APR-88, added: macros, predicates, load. With additions by
  53.     Barak.Pearlmutter@DOGHEN.BOLTZ.CS.CMU.EDU: Full flonum recognizer,
  54.     cleaned up uses of NULL/0. Now distributed with siod.scm.
  55.    Release 1.2: 28-APR-88, name changes as requested by JAR@AI.AI.MIT.EDU,
  56.     plus some bug fixes.
  57.    Release 1.3: 1-MAY-88, changed env to use frames instead of alist.
  58.     define now works properly. vms specific function edit.
  59.  
  60.    This example is small, has a garbage collector, and can run a good deal
  61.    of the code in Structure and Interpretation of Computer Programs.
  62.    (Start it up with the siod.scm file for more features).
  63.    Replacing the evaluator with an explicit control "flat-coded" one
  64.    as in chapter 5 would allow garbage collection to take place
  65.    at any time, not just at toplevel in the read-eval-print loop,
  66.    as herein implemented. This is left as an exersize for the reader.
  67.  
  68.    Techniques used will be familiar to most lisp implementors.
  69.    Having objects be all the same size, and having only two statically
  70.    allocated spaces simplifies and speeds up both consing and gc considerably.
  71.    The MSUBR hack allows for a modular implementation of tail recursion,
  72.    an extension of the FSUBR that is, as far as I know, original.
  73.  
  74.    Error handling is rather crude. A topic taken with machine fault,
  75.    exception handling, tracing, debugging, and state recovery
  76.    which we could cover in detail, but clearly beyond the scope of
  77.    this implementation. Suffice it to say that if you have a good
  78.    symbolic debugger you can set a break point at "err" and observe
  79.    in detail all the arguments and local variables of the procedures
  80.    in question, since there is no ugly "casting" of data types.
  81.    If X is an offending or interesting object then examining
  82.    X->type will give you the type, and X->storage_as.cons will
  83.    show the car and the cdr.
  84.  
  85.   */
  86.  
  87. #include <stdio.h>
  88. #include <string.h>
  89. #include <ctype.h>
  90. #include <setjmp.h>
  91. #include <signal.h>
  92. #include <math.h>
  93.  
  94. struct obj
  95. {short gc_mark;
  96.  short type;
  97.  union {struct {struct obj * car;
  98.         struct obj * cdr;} cons;
  99.     struct {double data;} flonum;
  100.     struct {char *pname;
  101.         struct obj * vcell;} symbol;
  102.     struct {char *name;
  103.         struct obj * (*f)();} subr;
  104.     struct {struct obj *env;
  105.         struct obj *code;} closure;}
  106.  storage_as;};
  107.  
  108. #define CAR(x) ((*x).storage_as.cons.car)
  109. #define CDR(x) ((*x).storage_as.cons.cdr)
  110. #define PNAME(x) ((*x).storage_as.symbol.pname)
  111. #define VCELL(x) ((*x).storage_as.symbol.vcell)
  112. #define SUBRF(x) (*((*x).storage_as.subr.f))
  113. #define FLONM(x) ((*x).storage_as.flonum.data)
  114.  
  115. struct obj *heap_1;
  116. struct obj *heap_2;
  117. struct obj *heap,*heap_end,*heap_org;
  118. long heap_size = 5000;
  119. long old_heap_used;
  120. int which_heap;
  121. int gc_status_flag = 1;
  122. char *init_file = (char *) NULL;
  123.  
  124. #define TKBUFFERN 100
  125.  
  126. char tkbuffer[TKBUFFERN];
  127.  
  128. jmp_buf errjmp;
  129. int errjmp_ok = 0;
  130. int nointerrupt = 1;
  131.  
  132. struct obj *cons(), *car(), *cdr(), *setcar(), *setcdr(),*consp();
  133. struct obj *symcons(),*rintern(),*cintern(),*cintern_soft(),*symbolp();
  134. struct obj *flocons(),*plus(),*ltimes(),*difference(),*quotient();
  135. struct obj *greaterp(),*lessp(),*eq(),*eql(),*numberp();
  136. struct obj *assq();
  137. struct obj *lread(),*leval(),*lprint(),*lprin1();
  138. struct obj *lreadr(),*lreadparen(),*lreadtk(),*lreadf();
  139. struct obj *subrcons(),*closure();
  140. struct obj *leval_define(),*leval_lambda(),*leval_if();
  141. struct obj *leval_progn(),*leval_setq(),*leval_let(),*let_macro();
  142. struct obj *leval_args(),*extend_env(),*setvar();
  143. struct obj *leval_quote(),*leval_and(),*leval_or();
  144. struct obj *oblistfn(),*copy_list();
  145. struct obj *gc_relocate(),*get_newspace(),*gc_status();
  146. struct obj *vload(),*load();
  147. struct obj *leval_tenv(),*lerr(),*quit(),*nullp();
  148. struct obj *symbol_boundp(),*symbol_value();
  149. struct obj *envlookup(),*arglchk(),*sys_edit(),*reverse();
  150.  
  151.  
  152. int handle_sigfpe();
  153. int handle_sigint();
  154.  
  155. #define NIL ((struct obj *) 0)
  156. #define EQ(x,y) ((x) == (y))
  157. #define NEQ(x,y) ((x) != (y))
  158. #define NULLP(x) EQ(x,NIL)
  159. #define NNULLP(x) NEQ(x,NIL)
  160.  
  161. #define TYPE(x) (((x) == NIL) ? 0 : ((*(x)).type))
  162.  
  163. #define TYPEP(x,y) (TYPE(x) == (y))
  164. #define NTYPEP(x,y) (TYPE(x) != (y))
  165.  
  166. #define tc_nil    0
  167. #define tc_cons   1
  168. #define tc_flonum 2
  169. #define tc_symbol 3
  170. #define tc_subr_0 4
  171. #define tc_subr_1 5
  172. #define tc_subr_2 6
  173. #define tc_subr_3 7
  174. #define tc_lsubr  8
  175. #define tc_fsubr  9
  176. #define tc_msubr  10
  177. #define tc_closure 11
  178.  
  179. init_subrs()
  180. {init_subr("cons",tc_subr_2,cons);
  181.  init_subr("car",tc_subr_1,car);
  182.  init_subr("cdr",tc_subr_1,cdr);
  183.  init_subr("set-car!",tc_subr_2,setcar);
  184.  init_subr("set-cdr!",tc_subr_2,setcdr);
  185.  init_subr("+",tc_subr_2,plus);
  186.  init_subr("-",tc_subr_2,difference);
  187.  init_subr("*",tc_subr_2,ltimes);
  188.  init_subr("/",tc_subr_2,quotient);
  189.  init_subr(">",tc_subr_2,greaterp);
  190.  init_subr("<",tc_subr_2,lessp);
  191.  init_subr("eq?",tc_subr_2,eq);
  192.  init_subr("eqv?",tc_subr_2,eql);
  193.  init_subr("assq",tc_subr_2,assq);
  194.  init_subr("read",tc_subr_0,lread);
  195.  init_subr("print",tc_subr_1,lprint);
  196.  init_subr("eval",tc_subr_2,leval);
  197.  init_subr("define",tc_fsubr,leval_define);
  198.  init_subr("lambda",tc_fsubr,leval_lambda);
  199.  init_subr("if",tc_msubr,leval_if);
  200.  init_subr("begin",tc_msubr,leval_progn);
  201.  init_subr("set!",tc_fsubr,leval_setq);
  202.  init_subr("or",tc_msubr,leval_or);
  203.  init_subr("and",tc_msubr,leval_and);
  204.  init_subr("quote",tc_fsubr,leval_quote);
  205.  init_subr("oblist",tc_subr_0,oblistfn);
  206.  init_subr("copy-list",tc_subr_1,copy_list);
  207.  init_subr("gc-status",tc_lsubr,gc_status);
  208.  init_subr("load",tc_subr_1,load);
  209.  init_subr("pair?",tc_subr_1,consp);
  210.  init_subr("symbol?",tc_subr_1,symbolp);
  211.  init_subr("number?",tc_subr_1,numberp);
  212.  init_subr("let-internal",tc_msubr,leval_let);
  213.  init_subr("let-internal-macro",tc_subr_1,let_macro);
  214.  init_subr("symbol-bound?",tc_subr_2,symbol_boundp);
  215.  init_subr("symbol-value",tc_subr_2,symbol_value);
  216.  init_subr("set-symbol-value!",tc_subr_3,setvar);
  217.  init_subr("the-environment",tc_fsubr,leval_tenv);
  218.  init_subr("error",tc_subr_2,lerr);
  219.  init_subr("quit",tc_subr_0,quit);
  220.  init_subr("not",tc_subr_1,nullp);
  221.  init_subr("null?",tc_subr_1,nullp);
  222.  init_subr("env-lookup",tc_subr_2,envlookup);
  223. #ifdef vms
  224.  init_subr("edit",tc_subr_1,sys_edit);
  225. #endif
  226.  init_subr("reverse",tc_subr_1,reverse);
  227.  }
  228.  
  229. struct obj *oblist = NIL;
  230. struct obj *truth = NIL;
  231. struct obj *eof_val = NIL;
  232. struct obj *sym_errobj = NIL;
  233. struct obj *sym_progn = NIL;
  234. struct obj *sym_lambda = NIL;
  235. struct obj *sym_quote = NIL;
  236. struct obj *open_files = NIL;
  237. struct obj *unbound_marker = NIL;
  238.  
  239. scan_registers()
  240. {oblist = gc_relocate(oblist);
  241.  eof_val = gc_relocate(eof_val);
  242.  truth = gc_relocate(truth);
  243.  sym_errobj = gc_relocate(sym_errobj);
  244.  sym_progn = gc_relocate(sym_progn);
  245.  sym_lambda = gc_relocate(sym_lambda);
  246.  sym_quote = gc_relocate(sym_quote);
  247.  open_files = gc_relocate(open_files);
  248.  unbound_marker = gc_relocate(unbound_marker);}
  249.  
  250. main(argc,argv)
  251.  int argc; char **argv;
  252. {printf("Welcome to SIOD, Scheme In One Defun, Version 1.3\n");
  253.  printf("(C) Copyright 1988, George Carrette\n");
  254.  process_cla(argc,argv);
  255.  printf("heap_size = %d cells, %d bytes\n",
  256.         heap_size,heap_size*sizeof(struct obj));
  257.  init_storage();
  258.  printf("heap_1 at 0x%X, heap_2 at 0x%X\n",heap_1,heap_2);
  259.  repl_driver();
  260.  printf("EXIT\n");}
  261.  
  262. process_cla(argc,argv)
  263.  int argc; char **argv;
  264. {int k;
  265.  for(k=1;k<argc;++k)
  266.    {if (strlen(argv[k])<2) continue;
  267.     if (argv[k][0] != '-') {printf("bad arg: %s\n",argv[k]);continue;}
  268.     switch(argv[k][1])
  269.       {case 'h':
  270.      heap_size = atol(&(argv[k][2])); break;
  271.        case 'i':
  272.      init_file = &(argv[k][2]); break;
  273.        default: printf("bad arg: %s\n",argv[k]);}}}
  274.  
  275. repl_driver()
  276. {int k;
  277.  k = setjmp(errjmp);
  278.  if (k == 2) return;
  279.  signal(SIGFPE,handle_sigfpe);
  280.  signal(SIGINT,handle_sigint);
  281.  close_open_files();
  282.  errjmp_ok = 1;
  283.  nointerrupt = 0;
  284.  if (init_file && (k == 0)) vload(init_file);
  285.  repl();}
  286.  
  287. #ifdef unix
  288. #ifdef sun
  289. double myruntime(){return(clock()*1.0e-6);}
  290. #else
  291. #ifdef encore
  292. double myruntime(){return(clock()*1.0e-6);}
  293. #else
  294. #include <sys/types.h>
  295. #include <sys/times.h>
  296. struct tms time_buffer;
  297. double myruntime(){times(&time_buffer);return(time_buffer.tms_utime/60.0);}
  298. #endif
  299. #endif
  300. #else
  301. #ifdef vms
  302. #include <stdlib.h>
  303. double myruntime(){return(clock() * 1.0e-2);}
  304. #include <descrip.h>
  305.  struct obj *
  306. sys_edit(fname)
  307.  struct obj *fname;
  308. {struct dsc$descriptor_s d;
  309.  if NTYPEP(fname,tc_symbol) err("filename not a symbol",fname);
  310.  d.dsc$b_dtype = DSC$K_DTYPE_T;
  311.  d.dsc$b_class = DSC$K_CLASS_S;
  312.  d.dsc$w_length = strlen(PNAME(fname));
  313.  d.dsc$a_pointer = PNAME(fname);
  314.  nointerrupt = 1;
  315.  edt$edit(&d);
  316.  nointerrupt = 0;
  317.  return(fname);}
  318. #else
  319. double myruntime(){long x;long time();time(&x);return(x);}
  320. #endif
  321. #endif
  322.  
  323. handle_sigfpe(sig,code,scp)
  324.  int sig,code; struct sigcontext *scp;
  325. {signal(SIGFPE,handle_sigfpe);
  326.  err("floating point exception",NIL);}
  327.  
  328. handle_sigint(sig,code,scp)
  329.  int sig,code; struct sigcontext *scp;
  330. {signal(SIGINT,handle_sigint);
  331.  if (nointerrupt == 0) err("control-c interrupt",NIL);
  332.  printf("interrupts disabled\n");}
  333.  
  334. repl() 
  335. {struct obj *x,*cw;
  336.  double rt;
  337.  while(1)
  338.    {if ((gc_status_flag) || heap >= heap_end)
  339.      {rt = myruntime();
  340.       gc();
  341.       printf("GC took %g seconds, %d compressed to %d, %d free\n",
  342.              myruntime()-rt,old_heap_used,heap-heap_org,heap_end-heap);}
  343.     printf("> ");
  344.     x = lread();
  345.     if EQ(x,eof_val) break;
  346.     rt = myruntime();
  347.     cw = heap;
  348.     x = leval(x,NIL);
  349.     printf("Evaluation took %g seconds %d cons work\n",
  350.        myruntime()-rt,heap-cw);
  351.     lprint(x);}}
  352.  
  353. err(message,x)
  354.  char *message; struct obj *x;
  355. {nointerrupt = 1;
  356.  if NNULLP(x) 
  357.     printf("ERROR: %s (see errobj)\n",message);
  358.   else printf("ERROR: %s\n",message);
  359.  if (errjmp_ok == 1) {setvar(sym_errobj,x,NIL); longjmp(errjmp,1);}
  360.  printf("FATAL ERROR DURING STARTUP OR CRITICAL CODE SECTION\n");
  361.  exit(1);}
  362.  
  363.  struct obj *
  364. lerr(message,x)
  365.  struct obj *message,*x;
  366. {if NTYPEP(message,tc_symbol) err("argument to error not a symbol",message);
  367.  err(PNAME(message),x);
  368.  return(NIL);}
  369.  
  370.  struct obj *
  371. cons(x,y)
  372.  struct obj *x,*y;
  373. {register struct obj *z;
  374.  if ((z = heap) >= heap_end) err("ran out of storage",NIL);
  375.  heap = z+1;
  376.  (*z).gc_mark = 0;
  377.  (*z).type = tc_cons;
  378.  CAR(z) = x;
  379.  CDR(z) = y;
  380.  return(z);}
  381.  
  382.  struct obj *
  383. consp(x)
  384.  struct obj *x;
  385. {if TYPEP(x,tc_cons) return(truth); else return(NIL);}
  386.  
  387.  struct obj *
  388. car(x)
  389.  struct obj *x;
  390. {switch TYPE(x)
  391.    {case tc_nil:
  392.       return(NIL);
  393.     case tc_cons:
  394.       return(CAR(x));
  395.     default:
  396.       err("wta to car",x);}}
  397.  
  398.  struct obj *
  399. cdr(x)
  400.  struct obj *x;
  401. {switch TYPE(x)
  402.    {case tc_nil:
  403.       return(NIL);
  404.     case tc_cons:
  405.       return(CDR(x));
  406.     default:
  407.       err("wta to cdr",x);}}
  408.  
  409.  struct obj *
  410. setcar(cell,value)
  411.  struct obj *cell,*value;
  412. {if NTYPEP(cell,tc_cons) err("wta to setcar",cell);
  413.  return(CAR(cell) = value);}
  414.  
  415.  struct obj *
  416. setcdr(cell,value)
  417.  struct obj *cell,*value;
  418. {if NTYPEP(cell,tc_cons) err("wta to setcdr",cell);
  419.  return(CDR(cell) = value);}
  420.  
  421.  struct obj *
  422. flocons(x)
  423.  double x;
  424. {register struct obj *z;
  425.  if ((z = heap) >= heap_end) err("ran out of storage",NIL);
  426.  heap = z+1;
  427.  (*z).gc_mark = 0;
  428.  (*z).type = tc_flonum;
  429.  (*z).storage_as.flonum.data = x;
  430.  return(z);}
  431.  
  432.  struct obj *
  433. numberp(x)
  434.  struct obj *x;
  435. {if TYPEP(x,tc_flonum) return(truth); else return(NIL);}
  436.  
  437.  struct obj *
  438. plus(x,y)
  439.  struct obj *x,*y;
  440. {if NTYPEP(x,tc_flonum) err("wta(1st) to plus",x);
  441.  if NTYPEP(y,tc_flonum) err("wta(2nd) to plus",y);
  442.  return(flocons(FLONM(x)+FLONM(y)));}
  443.  
  444.  struct obj *
  445. ltimes(x,y)
  446.  struct obj *x,*y;
  447. {if NTYPEP(x,tc_flonum) err("wta(1st) to times",x);
  448.  if NTYPEP(y,tc_flonum) err("wta(2nd) to times",y);
  449.  return(flocons(FLONM(x)*FLONM(y)));}
  450.  
  451.  struct obj *
  452. difference(x,y)
  453.  struct obj *x,*y;
  454. {if NTYPEP(x,tc_flonum) err("wta(1st) to difference",x);
  455.  if NTYPEP(y,tc_flonum) err("wta(2nd) to difference",y);
  456.  return(flocons(FLONM(x)-FLONM(y)));}
  457.  
  458.  struct obj *
  459. quotient(x,y)
  460.  struct obj *x,*y;
  461. {if NTYPEP(x,tc_flonum) err("wta(1st) to quotient",x);
  462.  if NTYPEP(y,tc_flonum) err("wta(2nd) to quotient",y);
  463.  return(flocons(FLONM(x)/FLONM(y)));}
  464.  
  465.  struct obj *
  466. greaterp(x,y)
  467.  struct obj *x,*y;
  468. {if NTYPEP(x,tc_flonum) err("wta(1st) to greaterp",x);
  469.  if NTYPEP(y,tc_flonum) err("wta(2nd) to greaterp",y);
  470.  if (FLONM(x)>FLONM(y)) return(truth);
  471.  return(NIL);}
  472.  
  473.  struct obj *
  474. lessp(x,y)
  475.  struct obj *x,*y;
  476. {if NTYPEP(x,tc_flonum) err("wta(1st) to lessp",x);
  477.  if NTYPEP(y,tc_flonum) err("wta(2nd) to lessp",y);
  478.  if (FLONM(x)<FLONM(y)) return(truth);
  479.  return(NIL);}
  480.  
  481.   struct obj *
  482. eq(x,y)
  483.  struct obj *x,*y;
  484. {if EQ(x,y) return(truth); else return(NIL);}
  485.  
  486.   struct obj *
  487. eql(x,y)
  488.  struct obj *x,*y;
  489. {if EQ(x,y) return(truth); else 
  490.  if NTYPEP(x,tc_flonum) return(NIL); else
  491.  if NTYPEP(y,tc_flonum) return(NIL); else
  492.  if (FLONM(x) == FLONM(y)) return(truth);
  493.  return(NIL);}
  494.  
  495.  struct obj *
  496. symcons(pname,vcell)
  497.  char *pname; struct obj *vcell;
  498. {register struct obj *z;
  499.  if ((z = heap) >= heap_end) err("ran out of storage",NIL);
  500.  heap = z+1;
  501.  (*z).gc_mark = 0;
  502.  (*z).type = tc_symbol;
  503.  PNAME(z) = pname;
  504.  VCELL(z) = vcell;
  505.  return(z);}
  506.  
  507.  struct obj *
  508. symbolp(x)
  509.  struct obj *x;
  510. {if TYPEP(x,tc_symbol) return(truth); else return(NIL);}
  511.  
  512.  struct obj *
  513. symbol_boundp(x,env)
  514.  struct obj *x,*env;
  515. {struct obj *tmp;
  516.  if NTYPEP(x,tc_symbol) err("not a symbol",x);
  517.  tmp = envlookup(x,env);
  518.  if NNULLP(tmp) return(truth);
  519.  if EQ(VCELL(x),unbound_marker) return(NIL); else return(truth);}
  520.  
  521.  struct obj *
  522. symbol_value(x,env)
  523.  struct obj *x,*env;
  524. {struct obj *tmp;
  525.  if NTYPEP(x,tc_symbol) err("not a symbol",x);
  526.  tmp = envlookup(x,env);
  527.  if NNULLP(tmp) return(CAR(tmp));
  528.  tmp = VCELL(x);
  529.  if EQ(tmp,unbound_marker) err("unbound variable",x);
  530.  return(tmp);}
  531.  
  532.  struct obj *
  533. cintern_soft(name)
  534.  char *name;
  535. {struct obj *l;
  536.  for(l=oblist;NNULLP(l);l=CDR(l))
  537.    if (strcmp(name,PNAME(CAR(l))) == 0) return(CAR(l));
  538.  return(NIL);}
  539.  
  540.  struct obj *
  541. cintern(name)
  542.  char *name;
  543. {struct obj *sym;
  544.  sym = cintern_soft(name);
  545.  if(sym) return(sym);
  546.  sym = symcons(name,unbound_marker);
  547.  oblist = cons(sym,oblist);
  548.  return(sym);}
  549.  
  550.  char *
  551. must_malloc(size)
  552.  unsigned long size;
  553. {char *tmp;
  554.  tmp = (char *) malloc(size);
  555.  if (tmp == (char *)NULL) err("failed to allocate storage from system",NIL);
  556.  return(tmp);}
  557.  
  558.  struct obj *
  559. rintern(name)
  560.  char *name;
  561. {struct obj *sym;
  562.  char *newname;
  563.  sym = cintern_soft(name);
  564.  if(sym) return(sym);
  565.  newname = must_malloc(strlen(name)+1);
  566.  strcpy(newname,name);
  567.  sym = symcons(newname,unbound_marker);
  568.  oblist = cons(sym,oblist);
  569.  return(sym);}
  570.  
  571.  struct obj *
  572. subrcons(type,name,f)
  573.  int type; char *name; struct obj * (*f)();
  574. {register struct obj *z;
  575.  if ((z = heap) >= heap_end) err("ran out of storage",NIL);
  576.  heap = z+1;
  577.  (*z).gc_mark = 0;
  578.  (*z).type = type;
  579.  (*z).storage_as.subr.name = name;
  580.  (*z).storage_as.subr.f = f;
  581.  return(z);}
  582.  
  583.  struct obj *
  584. closure(env,code)
  585.  struct obj *env,*code;
  586. {register struct obj *z;
  587.  if ((z = heap) >= heap_end) err("ran out of storage",NIL);
  588.  heap = z+1;
  589.  (*z).gc_mark = 0;
  590.  (*z).type = tc_closure;
  591.  (*z).storage_as.closure.env = env;
  592.  (*z).storage_as.closure.code = code;
  593.  return(z);}
  594.  
  595. init_storage()
  596. {int j;
  597.  heap_1 = (struct obj *)must_malloc(sizeof(struct obj)*heap_size);
  598.  heap_2 = (struct obj *)must_malloc(sizeof(struct obj)*heap_size);
  599.  heap = heap_1;
  600.  which_heap = 1;
  601.  heap_org = heap;
  602.  heap_end = heap + heap_size;
  603.  unbound_marker = cons(cintern("**unbound-marker**"),NIL);
  604.  eof_val = cons(cintern("eof"),NIL);
  605.  truth = cintern("t");
  606.  setvar(truth,truth,NIL);
  607.  setvar(cintern("nil"),NIL,NIL);
  608.  setvar(cintern("let"),cintern("let-internal-macro"),NIL);
  609.  sym_errobj = cintern("errobj");
  610.  setvar(sym_errobj,NIL,NIL);
  611.  sym_progn = cintern("begin");
  612.  sym_lambda = cintern("lambda");
  613.  sym_quote = cintern("quote");
  614.  init_subrs();}
  615.  
  616. init_subr(name,type,fcn)
  617.  char *name; int type; struct obj *(*fcn)();
  618. {setvar(cintern(name),subrcons(type,name,fcn),NIL);}
  619.  
  620.  struct obj *
  621. assq(x,alist)
  622.  struct obj *x,*alist;
  623. {register struct obj *l,*tmp;
  624.  for(l=alist;TYPEP(l,tc_cons);l=CDR(l))
  625.    {tmp = CAR(l);
  626.     if (TYPEP(tmp,tc_cons) && EQ(CAR(tmp),x)) return(tmp);}
  627.  if EQ(l,NIL) return(NIL);
  628.  err("improper list to assq",alist);}
  629.  
  630.  struct obj *
  631. gc_relocate(x)
  632.  struct obj *x;
  633. {struct obj *new;
  634.  if EQ(x,NIL) return(NIL);
  635.  if ((*x).gc_mark == 1) return(CAR(x));
  636.  switch TYPE(x)
  637.    {case tc_flonum:
  638.       new = flocons(FLONM(x));
  639.       break;
  640.     case tc_cons:
  641.       new = cons(CAR(x),CDR(x));
  642.       break;
  643.     case tc_symbol:
  644.       new = symcons(PNAME(x),VCELL(x));
  645.       break;
  646.     case tc_closure:
  647.       new = closure((*x).storage_as.closure.env,
  648.             (*x).storage_as.closure.code);
  649.       break;
  650.     case tc_subr_0:
  651.     case tc_subr_1:
  652.     case tc_subr_2:
  653.     case tc_subr_3:
  654.     case tc_lsubr:
  655.     case tc_fsubr:
  656.     case tc_msubr:
  657.       new = subrcons(TYPE(x),
  658.              (*x).storage_as.subr.name,
  659.              (*x).storage_as.subr.f);
  660.       break;
  661.     default: err("BUG IN GARBAGE COLLECTOR gc_relocate",NIL);}
  662.  (*x).gc_mark = 1;
  663.  CAR(x) = new;
  664.  return(new);}
  665.  
  666.  struct obj *
  667. get_newspace()
  668. {struct obj * newspace;
  669.  if (which_heap == 1)
  670.    {newspace = heap_2;
  671.     which_heap = 2;}
  672.  else
  673.    {newspace = heap_1;
  674.     which_heap = 1;}
  675.  heap = newspace;
  676.  heap_org = heap;
  677.  heap_end = heap + heap_size;
  678.  return(newspace);}
  679.  
  680. scan_newspace(newspace)
  681.  struct obj  *newspace;
  682. {register struct obj *ptr;
  683.  for(ptr=newspace; ptr < heap; ++ptr)
  684.    {switch TYPE(ptr)
  685.       {case tc_cons:
  686.        case tc_closure:
  687.      CAR(ptr) = gc_relocate(CAR(ptr));
  688.      CDR(ptr) = gc_relocate(CDR(ptr));
  689.      break;
  690.        case tc_symbol:
  691.      VCELL(ptr) = gc_relocate(VCELL(ptr));
  692.      break;
  693.        default:
  694.      break;}}}
  695.       
  696. gc()
  697. {struct obj *newspace;
  698.  errjmp_ok = 0;
  699.  nointerrupt = 1;
  700.  old_heap_used = heap - heap_org;
  701.  newspace = get_newspace();
  702.  scan_registers();
  703.  scan_newspace(newspace);
  704.  errjmp_ok = 1;
  705.  nointerrupt = 0;}
  706.  
  707.  struct obj *
  708. gc_status(args)
  709.  struct obj *args;
  710. {if NNULLP(args) 
  711.   if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
  712.  if (gc_status_flag)
  713.   printf("garbage collection is on\n"); else
  714.   printf("garbage collection is off\n");
  715.  printf("%d allocated %d free\n",heap - heap_org, heap_end - heap);
  716.  return(NIL);}
  717.  
  718.  struct obj *
  719. leval_args(l,env)
  720.  struct obj *l,*env;
  721. {struct obj *result,*v1,*v2,*tmp;
  722.  if NULLP(l) return(NIL);
  723.  if NTYPEP(l,tc_cons) err("bad syntax argument list",l);
  724.  result = cons(leval(CAR(l),env),NIL);
  725.  for(v1=result,v2=CDR(l);
  726.      TYPEP(v2,tc_cons);
  727.      v1 = tmp, v2 = CDR(v2))
  728.   {tmp = cons(leval(CAR(v2),env),NIL);
  729.    CDR(v1) = tmp;}
  730.  if NNULLP(v2) err("bad syntax argument list",l);
  731.  return(result);}
  732.  
  733.  struct obj *
  734. extend_env(actuals,formals,env)
  735.  struct obj *actuals,*formals,*env;
  736. {if TYPEP(formals,tc_symbol)
  737.     return(cons(cons(cons(formals,NIL),cons(actuals,NIL)),env));
  738.  return(cons(cons(formals,actuals),env));}
  739.  
  740.  struct obj *
  741. envlookup(var,env)
  742.  struct obj *var,*env;
  743. {struct obj *frame,*al,*fl,*tmp;
  744.  for(frame=env;TYPEP(frame,tc_cons);frame=CDR(frame))
  745.    {tmp = CAR(frame);
  746.     if NTYPEP(tmp,tc_cons) err("damaged frame",tmp);
  747.     for(fl=CAR(tmp),al=CDR(tmp);
  748.     TYPEP(fl,tc_cons);
  749.     fl=CDR(fl),al=CDR(al))
  750.       {if NTYPEP(al,tc_cons) err("too few arguments",tmp);
  751.        if EQ(CAR(fl),var) return(al);}}
  752.  if NNULLP(frame) err("damaged env",env);
  753.  return(NIL);}
  754.  
  755.  struct obj *
  756. leval(x,env)
  757.  struct obj *x,*env;
  758. {struct obj *tmp;
  759.  loop:
  760.  switch TYPE(x)
  761.    {case tc_symbol:
  762.       tmp = envlookup(x,env);
  763.       if (tmp) return(CAR(tmp));
  764.       tmp = VCELL(x);
  765.       if EQ(tmp,unbound_marker) err("unbound variable",x);
  766.       return(tmp);
  767.     case tc_cons:
  768.       tmp = leval(CAR(x),env);
  769.       switch TYPE(tmp)
  770.     {case tc_subr_0:
  771.        return(SUBRF(tmp)());
  772.      case tc_subr_1:
  773.        return(SUBRF(tmp)(leval(car(CDR(x)),env)));
  774.      case tc_subr_2:
  775.        return(SUBRF(tmp)(leval(car(CDR(x)),env),
  776.                  leval(car(cdr(CDR(x))),env)));
  777.      case tc_subr_3:
  778.        return(SUBRF(tmp)(leval(car(CDR(x)),env),
  779.                  leval(car(cdr(CDR(x))),env),
  780.                  leval(car(cdr(cdr(CDR(x)))),env)));
  781.      case tc_lsubr:
  782.        return(SUBRF(tmp)(leval_args(CDR(x),env)));
  783.      case tc_fsubr:
  784.        return(SUBRF(tmp)(CDR(x),env));
  785.      case tc_msubr:
  786.        if NULLP(SUBRF(tmp)(&x,&env)) return(x);
  787.        goto loop;
  788.      case tc_closure:
  789.        env = extend_env(leval_args(CDR(x),env),
  790.                 car((*tmp).storage_as.closure.code),
  791.                 (*tmp).storage_as.closure.env);
  792.        x = cdr((*tmp).storage_as.closure.code);
  793.        goto loop;
  794.      case tc_symbol:
  795.        x = cons(tmp,cons(cons(sym_quote,cons(x,NIL)),NIL));
  796.        x = leval(x,NIL);
  797.        goto loop;
  798.      default:
  799.        err("bad function",tmp);}
  800.     default:
  801.       return(x);}}
  802.  
  803.  struct obj *
  804. setvar(var,val,env)
  805.  struct obj *var,*val,*env;
  806. {struct obj *tmp;
  807.  if NTYPEP(var,tc_symbol) err("wta(non-symbol) to setvar",var);
  808.  tmp = envlookup(var,env);
  809.  if NULLP(tmp) return(VCELL(var) = val);
  810.  return(CAR(tmp)=val);}
  811.  
  812.  
  813.  struct obj *
  814. leval_setq(args,env)
  815.  struct obj *args,*env;
  816. {return(setvar(car(args),leval(car(cdr(args)),env),env));}
  817.  
  818.  struct obj *
  819. syntax_define(args)
  820.  struct obj *args;
  821. {if TYPEP(car(args),tc_symbol) return(args);
  822.  return(syntax_define(
  823.         cons(car(car(args)),
  824.     cons(cons(sym_lambda,
  825.          cons(cdr(car(args)),
  826.           cdr(args))),
  827.          NIL))));}
  828.       
  829.  struct obj *
  830. leval_define(args,env)
  831.  struct obj *args,*env;
  832. {struct obj *tmp,*var,*val;
  833.  tmp = syntax_define(args);
  834.  var = car(tmp);
  835.  if NTYPEP(var,tc_symbol) err("wta(non-symbol) to define",var);
  836.  val = leval(car(cdr(tmp)),env);
  837.  tmp = envlookup(var,env);
  838.  if NNULLP(tmp) return(CAR(tmp) = val);
  839.  if NULLP(env) return(VCELL(var) = val);
  840.  tmp = car(env);
  841.  setcar(tmp,cons(var,car(tmp)));
  842.  setcdr(tmp,cons(val,cdr(tmp)));
  843.  return(val);}
  844.  
  845.  struct obj *
  846. leval_if(pform,penv)
  847.  struct obj **pform,**penv;
  848. {struct obj *args,*env;
  849.  args = cdr(*pform);
  850.  env = *penv;
  851.  if NNULLP(leval(car(args),env)) 
  852.     *pform = car(cdr(args)); else *pform = car(cdr(cdr(args)));
  853.  return(truth);}
  854.  
  855.  struct obj *
  856. leval_lambda(args,env)
  857.  struct obj *args,*env;
  858. {struct obj *body;
  859.  if NULLP(cdr(cdr(args)))
  860.    body = car(cdr(args));
  861.   else body = cons(sym_progn,cdr(args));
  862.  return(closure(env,cons(arglchk(car(args)),body)));}
  863.                          
  864.  struct obj *
  865. leval_progn(pform,penv)
  866.  struct obj **pform,**penv;
  867. {struct obj *env,*l,*next;
  868.  env = *penv;
  869.  l = cdr(*pform);
  870.  next = cdr(l);
  871.  while(NNULLP(next)) {leval(car(l),env);l=next;next=cdr(next);}
  872.  *pform = car(l); 
  873.  return(truth);}
  874.  
  875.  struct obj *
  876. leval_or(pform,penv)
  877.  struct obj **pform,**penv;
  878. {struct obj *env,*l,*next,*val;
  879.  env = *penv;
  880.  l = cdr(*pform);
  881.  next = cdr(l);
  882.  while(NNULLP(next))
  883.    {val = leval(car(l),env);
  884.     if NNULLP(val) {*pform = val; return(NIL);}
  885.     l=next;next=cdr(next);}
  886.  *pform = car(l); 
  887.  return(truth);}
  888.  
  889.  struct obj *
  890. leval_and(pform,penv)
  891.  struct obj **pform,**penv;
  892. {struct obj *env,*l,*next;
  893.  env = *penv;
  894.  l = cdr(*pform);
  895.  if NULLP(l) {*pform = truth; return(NIL);}
  896.  next = cdr(l);
  897.  while(NNULLP(next))
  898.    {if NULLP(leval(car(l),env)) {*pform = NIL; return(NIL);}
  899.     l=next;next=cdr(next);}
  900.  *pform = car(l); 
  901.  return(truth);}
  902.  
  903.  struct obj *
  904. leval_let(pform,penv)
  905.  struct obj **pform,**penv;
  906. {struct obj *env,*l;
  907.  l = cdr(*pform);
  908.  env = *penv;
  909.  *penv = extend_env(leval_args(car(cdr(l)),env),car(l),env);
  910.  *pform = car(cdr(cdr(l)));
  911.  return(truth);}
  912.  
  913.  struct obj *
  914. reverse(l)
  915.  struct obj *l;
  916. {struct obj *n,*p;
  917.  n = NIL;
  918.  for(p=l;NNULLP(p);p=cdr(p)) n = cons(car(p),n);
  919.  return(n);}
  920.  
  921.  struct obj *
  922. let_macro(form)
  923.  struct obj *form;
  924. {struct obj *p,*fl,*al,*tmp;
  925.  fl = NIL;
  926.  al = NIL;
  927.  for(p=car(cdr(form));NNULLP(p);p=cdr(p))
  928.   {tmp = car(p);
  929.    if TYPEP(tmp,tc_symbol) {fl = cons(tmp,fl); al = cons(NIL,al);}
  930.    else {fl = cons(car(tmp),fl); al = cons(car(cdr(tmp)),al);}}
  931.  p = cdr(cdr(form));
  932.  if NULLP(cdr(p)) p = car(p); else p = cons(sym_progn,p);
  933.  setcdr(form,cons(reverse(fl),cons(reverse(al),cons(p,NIL))));
  934.  setcar(form,cintern("let-internal"));
  935.  return(form);}
  936.    
  937.   struct obj *
  938. leval_quote(args,env)
  939.  struct obj *args,*env;
  940. {return(car(args));}
  941.  
  942.  struct obj *
  943. leval_tenv(args,env)
  944.  struct obj *args,*env;
  945. {return(env);}
  946.  
  947.  struct obj *
  948. lprint(exp)
  949.  struct obj *exp;
  950. {lprin1(exp);
  951.  printf("\n");
  952.  return(NIL);}
  953.  
  954.  struct obj *
  955. lprin1(exp)
  956.  struct obj *exp;
  957. {struct obj *tmp;
  958.  switch TYPE(exp)
  959.    {case tc_nil:
  960.       printf("()");
  961.       break;
  962.    case tc_cons:
  963.       printf("(");
  964.       lprin1(car(exp));
  965.       for(tmp=cdr(exp);TYPEP(tmp,tc_cons);tmp=cdr(tmp))
  966.     {printf(" ");lprin1(car(tmp));}
  967.       if NNULLP(tmp) {printf(" . ");lprin1(tmp);}
  968.       printf(")");
  969.       break;
  970.     case tc_flonum:
  971.       printf("%g",FLONM(exp));
  972.       break;
  973.     case tc_symbol:
  974.       printf("%s",PNAME(exp));
  975.       break;
  976.     case tc_subr_0:
  977.     case tc_subr_1:
  978.     case tc_subr_2:
  979.     case tc_subr_3:
  980.     case tc_lsubr:
  981.     case tc_fsubr:
  982.     case tc_msubr:
  983.       printf("#<SUBR(%d) %s>",TYPE(exp),(*exp).storage_as.subr.name);
  984.       break;
  985.     case tc_closure:
  986.       printf("#<CLOSURE ");
  987.       lprin1(car((*exp).storage_as.closure.code));
  988.       printf(" ");
  989.       lprin1(cdr((*exp).storage_as.closure.code));
  990.       printf(">");
  991.       break;}
  992.  return(NIL);}
  993.  
  994.  struct obj *
  995. lread()
  996. {return(lreadf(stdin));}
  997.  
  998.  int
  999. flush_ws(f,eoferr)
  1000.  FILE *f;
  1001.  char *eoferr;
  1002. {int c;
  1003.  while(1)
  1004.    {c = getc(f);
  1005.     if (c == EOF) if (eoferr) err(eoferr,NIL); else return(c);
  1006.     if (isspace(c)) continue;
  1007.     return(c);}}
  1008.  
  1009.  struct obj *
  1010. lreadf(f)
  1011.  FILE *f;
  1012. {int c;
  1013.  c = flush_ws(f,(char *)NULL);
  1014.  if (c == EOF) return(eof_val);
  1015.  ungetc(c,f);
  1016.  return(lreadr(f));}
  1017.  
  1018.  struct obj *
  1019. lreadr(f)
  1020.  FILE *f;
  1021. {int c,j;
  1022.  char *p;
  1023.  c = flush_ws(f,"end of file inside read");
  1024.  switch (c)
  1025.    {case '(':
  1026.       return(lreadparen(f));
  1027.     case ')':
  1028.       err("unexpected close paren",NIL);
  1029.     case '\'':
  1030.       return(cons(sym_quote,cons(lreadr(f),NIL)));}
  1031.  p = tkbuffer;
  1032.  *p++ = c;
  1033.  for(j = 1; j<TKBUFFERN; ++j)
  1034.    {c = getc(f);
  1035.     if (c == EOF) return(lreadtk(j));
  1036.     if (isspace(c)) return(lreadtk(j));
  1037.     if (strchr("()'",c)) {ungetc(c,f);return(lreadtk(j));}
  1038.     *p++ = c;}
  1039.  err("token larger than TKBUFFERN",NIL);}
  1040.  
  1041. struct obj *
  1042. lreadparen(f)
  1043.  FILE *f;
  1044. {int c;
  1045.  struct obj *tmp;
  1046.  c = flush_ws(f,"end of file inside list");
  1047.  if (c == ')') return(NIL);
  1048.  ungetc(c,f);
  1049.  tmp = lreadr(f);
  1050.  return(cons(tmp,lreadparen(f)));}
  1051.  
  1052.  struct obj *
  1053. lreadtk(j)
  1054.  int j;
  1055. {int k;
  1056.  char c,*p;
  1057.  p = tkbuffer;
  1058.  p[j] = 0;
  1059.  if (*p == '-') p+=1;
  1060.  { int adigit = 0;
  1061.    while(isdigit(*p)) {p+=1; adigit=1;}
  1062.    if (*p=='.') {
  1063.      p += 1;
  1064.      while(isdigit(*p)) {p+=1; adigit=1;}}
  1065.    if (!adigit) goto a_symbol; }
  1066.  if (*p=='e') {
  1067.    p+=1;
  1068.    if (*p=='-'||*p=='+') p+=1;
  1069.    if (!isdigit(*p)) goto a_symbol; else p+=1;
  1070.    while(isdigit(*p)) p+=1; }
  1071.  if (*p) goto a_symbol;
  1072.  return(flocons(atof(tkbuffer)));
  1073.  a_symbol:
  1074.  return(rintern(tkbuffer));}
  1075.       
  1076.  struct obj *
  1077. copy_list(x)
  1078.  struct obj *x;
  1079. {if NULLP(x) return(NIL);
  1080.  return(cons(car(x),copy_list(cdr(x))));}
  1081.  
  1082.  struct obj *
  1083. oblistfn()
  1084. {return(copy_list(oblist));}
  1085.  
  1086. close_open_files()
  1087. {struct obj *l;
  1088.  FILE *p;
  1089.  for(l=open_files;NNULLP(l);l=cdr(l))
  1090.    {p = (FILE *) PNAME(car(l));
  1091.     if (p)
  1092.       {printf("closing a file left open\n");
  1093.        fclose(p);}}
  1094.  open_files = NIL;}
  1095.  
  1096.  
  1097.  struct obj *
  1098. vload(fname)
  1099.  char *fname;
  1100. {struct obj *sym,*form;
  1101.  FILE *f;
  1102.  printf("loading %s\n",fname);
  1103.  sym = symcons(0,NIL);
  1104.  open_files = cons(sym,open_files);
  1105.  PNAME(sym) = (char *) fopen(fname,"r");
  1106.  f = (FILE *) PNAME(sym);
  1107.  if (!f) {open_files = cdr(open_files);
  1108.       printf("Could not open file\n");
  1109.       return(NIL);}
  1110.  while(1)
  1111.    {form = lreadf(f);
  1112.     if EQ(form,eof_val) break;
  1113.     leval(form,NIL);}
  1114.  fclose(f);
  1115.  open_files = cdr(open_files);
  1116.  printf("done.\n");
  1117.  return(truth);}
  1118.  
  1119.  struct obj *
  1120. load(fname)
  1121.  struct obj *fname;
  1122. {if NTYPEP(fname,tc_symbol) err("filename not a symbol",fname);
  1123.  return(vload(PNAME(fname)));}
  1124.  
  1125.  struct obj *
  1126. quit()
  1127. {longjmp(errjmp,2);
  1128.  return(NIL);}
  1129.  
  1130.  struct obj *
  1131. nullp(x)
  1132.  struct obj *x;
  1133. {if EQ(x,NIL) return(truth); else return(NIL);}
  1134.  
  1135.  struct obj *
  1136. arglchk(x)
  1137.  struct obj *x;
  1138. {struct obj *l;
  1139.  if TYPEP(x,tc_symbol) return(x);
  1140.  for(l=x;TYPEP(l,tc_cons);l=CDR(l));
  1141.  if NNULLP(l) err("improper formal argument list",x);
  1142.  return(x);}
  1143.  
  1144.    
  1145. SHAR_EOF
  1146. cat << \SHAR_EOF > siod.doc
  1147. SIOD: Scheme In One Defun
  1148. (c) Copyright 1988 George Carrette, gjc@bu-it.bu.edu
  1149. For demonstration purposes only.
  1150.  
  1151. If your interests run to practical applications of symbolic programming
  1152. techniques, in LISP, Macsyma, C, or other language:
  1153.  
  1154.    Paradigm Associates Inc          Phone: 617-492-6079
  1155.    29 Putnam Ave, Suite 6
  1156.    Cambridge, MA 02138
  1157.  
  1158. Documentation for Release 1.3 1-MAY-88
  1159. Updated with more detail for experimenters on 17-MAY-88.
  1160.  
  1161. [SUBJECT INDEX:]
  1162.  [SUBJECT INDEX]
  1163.  [FILES]
  1164.  [COMPILATION]
  1165.  [INVOCATION]
  1166.  [SYSTEM]
  1167.  [SYNTAX]
  1168.  [SPECIAL FORMS]
  1169.  [MACRO SPECIAL FORMS]
  1170.  [BUILT-IN PROCEDURES]
  1171.  [UTILITIES IN SIOD.SCM]
  1172.  [A STREAMS IMPLEMENTATION]
  1173.  [BENCHMARKS]
  1174.  [PORTING]
  1175.  [ADDING NEW SUBRS]
  1176.  
  1177. [Files:]
  1178.  
  1179.  siod.c   The source in C, approximately 28 thousand bytes.
  1180.  siod.doc This file, approximately 8 thousand bytes.
  1181.  siod.scm Some utility function written in Scheme.
  1182.  
  1183. [Compilation:]
  1184.  
  1185. The code has been compiled and run by the author on Sun III and IV,
  1186. Encore Multimax, 4.3BSD VAX, VAX/VMS, and AMIGA 500 using the Lattice C
  1187. compiler.
  1188.  
  1189. On all unix machines use
  1190.  
  1191.   %cc -o siod siod.c
  1192.  
  1193. on VAX/VMS:
  1194.  
  1195.   $ cc siod
  1196.   $ link siod,sys$input:/opt
  1197.   sys$library:vaxcrtl/share
  1198.   $ siod == "$" + F$ENV("DEFAULT") + "SIOD"
  1199.  
  1200. on AMIGA 500, ignore warning messages about return value mismatches,
  1201.   %lc siod.c
  1202.   %blink lib:c.o,siod.o to siod lib lib:lcm.lib,lib:lc.lib,lib:amiga.lib
  1203.  
  1204.  
  1205. [Invocation:]
  1206.  
  1207. siod [-hXXXXX] [-iXXXXX]
  1208.  -h where XXXXX is an integer, to specify the heap size, in obj cells,
  1209.  -i where XXXXX is a filename to load before going into the repl loop.
  1210.  
  1211.   Example:
  1212.    siod -isiod.scm -h100000
  1213.  
  1214. [System:]
  1215.  
  1216. The interrupts called SIGINT and SIGFPE by the C runtime system are
  1217. handled by invoking the lisp error procedure. SIGINT is usually caused
  1218. by the CONTROL-C character and SIGFPE by floating point overflow or underflow.
  1219.  
  1220. [Syntax:]
  1221.  
  1222. The only special characters are the parenthesis and single quote.
  1223. Everything else, besides whitespace of course, will make up a regular token.
  1224. These tokens are either symbols or numbers depending on what they look like.
  1225. Dotted-list notation is not supported on input, only on output.
  1226.  
  1227. [Special forms:]
  1228.  
  1229. The CAR of a list is evaluated first, if the value is a SUBR of type 9 or 10
  1230. then it is a special form.
  1231.  
  1232. (define symbol value) is presently like (set! symbol value).
  1233.  
  1234. (define (f . arglist) . body) ==> (define f (lambda arglist . body))
  1235.  
  1236. (lambda arglist . body) Returns a closure.
  1237.  
  1238. (if pred val1 val2) If pred evaluates to () then val2 is evaluated else val1.
  1239.  
  1240. (begin . body) Each form in body is evaluated with the result of the last
  1241. returned.
  1242.  
  1243. (set! symbol value) Evaluates value and sets the local or global value of
  1244. the symbol.
  1245.  
  1246. (or x1 x2 x3 ...) Returns the first Xn such that Xn evaluated non-().
  1247.  
  1248. (and x1 x2 x3 ...) Keeps evaluating Xj until one returns (), or Xn.
  1249.  
  1250. (quote form). Input syntax 'form, returns form without evaluation.
  1251.  
  1252. (let pairlist . body) Each element in pairlist is (variable value).
  1253. Evaluates each value then sets of new bindings for each of the variables,
  1254. then evaluates the body like the body of a progn. This is actually
  1255. implemented as a macro turning into a let-internal form.
  1256.  
  1257. (the-environment) Returns the current lexical environment.
  1258.  
  1259. [Macro Special forms:]
  1260.  
  1261. If the CAR of a list evaluates to a symbol then the value of that symbol
  1262. is called on a single argument, the original form. The result of this
  1263. application is a new form which is recursively evaluated.
  1264.  
  1265. [Built-In functions:]
  1266.  
  1267. These are all SUBR's of type 4,5,6,7, taking from 0 to 3 arguments
  1268. with extra arguments ignored, (not even evaluated!) and arguments not
  1269. given defaulting to (). SUBR's of type 8 are lexprs, receiving a list
  1270. of arguments. Order of evaluation of arguments will depend on the
  1271. implementation choice of your system C compiler.
  1272.  
  1273. consp cons car cdr setcar setcdr
  1274.  
  1275. number? + - * / < > eqv?
  1276. The arithmetic functions all take two arguments.
  1277.  
  1278. eq?, pointer objective identity, eqv? also works on numbers.
  1279.  
  1280. symbol?
  1281.  
  1282. symbol-bound? takes an optional environment structure.
  1283. symbol-value also takes optional env.
  1284. set-symbol-value also takes optional env.
  1285.  
  1286. env-lookup takes a symbol and an environment structure. If it returns
  1287. non-nil the CAR will be the value of the symbol.
  1288.  
  1289. assq
  1290.  
  1291. read,print
  1292.  
  1293. eval, takes a second argument, an environment.
  1294.  
  1295. copy-list. Copies the top level conses in a list.
  1296.  
  1297. oblist, returns a copy of the list of the symbols that have been interned.
  1298.  
  1299. gc-status, prints out the status of garbage collection services, the
  1300. number of cells allocated and the number of cells free. If given
  1301. a () argument turns gc services off, if non-() then turns gc services on.
  1302.  
  1303. load, given a filename (which must be a symbol, there are no strings)
  1304. will read/eval all the forms in that file.
  1305.  
  1306. quit, will exit back to the operating system.
  1307.  
  1308. error, takes a symbol as its first argument, prints the pname of this
  1309. as an error message. The second argument (optional) is an offensive
  1310. object. The global variable errobj gets set to this object for later
  1311. observation.
  1312.  
  1313. null?, not. are the same thing.
  1314.  
  1315. edit is a VMS specific function that takes a single filename argument
  1316. and calls the sharable EDT editor to edit the file.
  1317.  
  1318. [Utility procedures in siod.scm:]
  1319.  
  1320. Shows how to define macros.
  1321.  
  1322. cadr,caddr,cdddr,replace,list.
  1323.  
  1324. (defvar variable default-value)
  1325.  
  1326. And for us old maclisp hackers, setq and defun, and progn, etc.
  1327.  
  1328. [A streams implementation:]
  1329.  
  1330. The first thing we must do is decide how to represent a stream.
  1331. There is only one reasonable data structure available to us, the list.
  1332. So we might use (<stream-car> <cache-flag> <cdr-cache> <cdr-procedure>)
  1333.  
  1334. the-empty-stream is just ().
  1335.  
  1336. empty-stream?
  1337.  
  1338. head
  1339.  
  1340. tail
  1341.  
  1342. cons-stream is a special form. Wraps a lambda around the second argument.
  1343.  
  1344. *cons-stream is the low-level constructor used by cons-stream.
  1345.  
  1346. [Benchmarks:]
  1347.  
  1348. A standard-fib procedure is included in siod.scm so that everyone will
  1349. use the same definition in any reports of speed. Make sure the return
  1350. result is correct. use command line argument of
  1351.  %siod -h100000 -isiod.scm
  1352.  
  1353. (standard-fib 10) => 55 ; 795 cons work.
  1354. (standard-fib 15) => 610 ; 8877 cons work.
  1355. (standard-fib 20) => 6765 ; 98508 cons work.
  1356.  
  1357. [Porting:]
  1358.  
  1359. The only code under #ifdef is the definition of myruntime, which
  1360. should be defined to return a double float, the number of cpu seconds
  1361. used by the process so far. This is currently specific for encore and
  1362. sun unix, with a default unix which would work on any 4.2BSD derived
  1363. system. The other specific case is vms, and the last default has
  1364. myruntime calling the time function, which usually means an integer
  1365. number of realtime seconds. Nested ifdef's are very difficult to
  1366. read of course. Sorry.
  1367.  
  1368. There is a bit of type casting in close_open_files and vload. The
  1369. pname of an un-interned symbol is used as a pointer to FILE. This
  1370. saves the code (a conser, a print case, and two gc cases) of defining
  1371. a new data type for keeping track of binary data. Are there any machines
  1372. where a pointer to char and a pointer to FILE are different?
  1373.  
  1374. There should be no problem with integers vs longs on short integer
  1375. machines.
  1376.  
  1377. [Adding new SUBRS:]
  1378.  (1) choose a name for it and add a forward declaration to the group
  1379.      of various forward declarations near the beginning of the file.
  1380.      The arguments must all be of type struct obj *, as is the return value.
  1381.  (2) choose a lisp name and add a call to init_subr for it near all the
  1382.      other calls in the procedure init_subrs. The first argument to init_subr
  1383.      is the lisp name as a string, the second is a subr type code, and the
  1384.      third is the name of the C coded procedure.
  1385.      Dont bother with special forms without detailed understanding of how
  1386.      msubrs in particular work. Use tc_subr_0 to get zero arguments through
  1387.      tc_subr_3 for three arguments. Otherwise use tc_lsubr to receive a
  1388.      single list of evaluated arguments.
  1389.  (3) If you need to use stack lisp variables (you can always use
  1390.      calls to cintern to get a handle on a symbol however) these must
  1391.      be declared before the procedure scan_registers, always init to NIL,
  1392.      and explicitely relocated in the scan_register procedure.
  1393.  (4) inside your subr you need not worry about gc relocating since the gc
  1394.      wont go off except at toplevel. You must of course be conservative
  1395.      about your using of cons and flocons if your procedure will have to 
  1396.      run long. Since symbol pnames ARE NOT RELOCATED you do not have to worry
  1397.      about passing the pname string of a symbol to a system procedure that will
  1398.      keep an unprotected pointer to it, even across toplevel calls to GC.
  1399.      However, do not pass pointers to things such as &(FLONM(x)) if the
  1400.      called procedure is going to keep that pointer in its internal storage
  1401.      after it returns. Never pass pointers to lisp data to system routines
  1402.      which may asynchronously go off (such as VMS AST's) at a later time
  1403.      and use that pointer data. Instead you may want to cons an uninterned
  1404.      symbol, malloc some data, and set the symbol PNAME to that data
  1405.      if you want to keep track of it. Example kludge:
  1406.       m = "Binary_DATA_"
  1407.       x = (char *) malloc(3+strlen(m)+1+data_needed);
  1408.       y = symcons(x,NIL);
  1409.       sprintf(x,"%s%3d",m,data_needed);
  1410.      The print name of the symbol Y will be harmless looking enough,
  1411.      because of the zero terminating byte put in by sprintf,
  1412.      but the C programmer will know that its pname points to more
  1413.      interesting goodies inside. The VCELL part of the symbol should
  1414.      come in handy for storing other things, like an alist of object
  1415.      properties perhaps. This just goes to show you that you dont need
  1416.      to go through a lot of trouble, like definining new primitive lisp
  1417.      object types and modifying the printer, to get something useful.
  1418.  
  1419.  
  1420. SHAR_EOF
  1421. cat << \SHAR_EOF > siod.n
  1422. .TH SIOD 1C LOCAL 
  1423. .SH NAME
  1424. siod \- small scheme interpreter (Scheme In One Defun).
  1425. .SH SYNOPSIS
  1426. .B siod
  1427. [-hXXXXX] [-iXXXXX]
  1428. .SH DESCRIPTION
  1429. .I Siod
  1430. is a very small scheme interpreter which can be used for short calculations
  1431. or included as a command interpreter or extension/macro language in other
  1432. applications.
  1433.  
  1434. .RE
  1435. .SS COMMAND LINE OPTIONS
  1436. .TP 8
  1437. .BI \-h "XXXXX"
  1438. The
  1439. .I XXXXX
  1440. should be an integer, specifying the number of cons cells to
  1441. allocate in the heap. The default is 5000.
  1442. .TP
  1443. .BI \-i "XXXXX"
  1444. The 
  1445. .I XXXXX
  1446. should be the name of an init file to load before going into
  1447. the read/eval/print loop.
  1448. .SH FILES
  1449. siod.doc siod.scm
  1450. .PD
  1451. .SH SEE ALSO
  1452. .I Structure and Interpretation of Computer Programs
  1453. , by Ableson and Sussman, MIT PRESS.
  1454. .SH DIAGNOSTICS
  1455. Error messages may also set the variable errobj to the offending object.
  1456. .SH BUGS
  1457. Does not GC during EVAL, only before each READ/EVAL/PRINT cycle.
  1458. SHAR_EOF
  1459. cat << \SHAR_EOF > siod.scm
  1460. '(SIOD: Scheme In One Defun
  1461.   (c) Copyright 1988 George Carrette, gjc@bu-it.bu.edu
  1462.   For demonstration purposes only.
  1463.   Optional Runtime Library for Release 1.3)
  1464.  
  1465. (define list (lambda n n))
  1466.  
  1467. (define (sublis l exp)
  1468.   (if (cons? exp)
  1469.       (cons (sublis l (car exp))
  1470.         (sublis l (cdr exp)))
  1471.       (let ((cell (assq exp l)))
  1472.     (if cell (cdr cell) exp))))
  1473.  
  1474. (define (cadr x) (car (cdr x)))
  1475. (define (caddr x) (car (cdr (cdr x))))
  1476. (define (cdddr x) (cdr (cdr (cdr x))))
  1477.  
  1478. (define (replace before after)
  1479.   (set-car! before (car after))
  1480.   (set-cdr! before (cdr after))
  1481.   after)
  1482.  
  1483. (define (push-macro form)
  1484.   (replace form
  1485.        (list 'set! (caddr form)
  1486.          (list 'cons (cadr form) (caddr form)))))
  1487.  
  1488. (define (pop-macro form)
  1489.   (replace form
  1490.        (list 'let (list (list 'tmp (cadr form)))
  1491.          (list 'set! (cadr form) '(cdr tmp))
  1492.          '(car tmp))))
  1493.  
  1494. (define push 'push-macro)
  1495. (define pop 'pop-macro)
  1496.  
  1497. (define (defvar-macro form)
  1498.   (list 'or
  1499.     (list 'value-cell (list 'quote (cadr form)))
  1500.     (list 'define (cadr form) (caddr form))))
  1501.  
  1502. (define defvar 'defvar-macro)
  1503.  
  1504. (define (defun-macro form)
  1505.   (cons 'define
  1506.     (cons (cons (cadr form) (caddr form))
  1507.           (cdddr form))))
  1508.  
  1509. (define defun 'defun-macro)
  1510.        
  1511. (define setq set!)
  1512. (define progn begin)
  1513.  
  1514. (define the-empty-stream ())
  1515.  
  1516. (define empty-stream? null?)
  1517.  
  1518. (define (*cons-stream head tail-future)
  1519.   (list head () () tail-future))
  1520.  
  1521. (define head car)
  1522.  
  1523. (define (tail x)
  1524.   (if (car (cdr x))
  1525.       (car (cdr (cdr x)))
  1526.       (let ((value ((car (cdr (cdr (cdr x)))))))
  1527.     (set-car! (cdr x) t)
  1528.     (set-car! (cdr (cdr x)) value))))
  1529.  
  1530. (define (cons-stream-macro form)
  1531.   (replace form
  1532.        (list '*cons-stream
  1533.          (cadr form)
  1534.          (list 'lambda () (caddr form)))))
  1535.  
  1536. (define cons-stream 'cons-stream-macro)
  1537.  
  1538. (define (enumerate-interval low high)
  1539.   (if (> low high)
  1540.       the-empty-stream
  1541.       (cons-stream low (enumerate-interval (+ low 1) high))))
  1542.  
  1543. (define (print-stream-elements x)
  1544.   (if (empty-stream? x)
  1545.       ()
  1546.       (begin (print (head x))
  1547.          (print-stream-elements (tail x)))))
  1548.  
  1549. (define (standard-fib x)
  1550.   (if (< x 2)
  1551.       x
  1552.       (+ (standard-fib (- x 1))
  1553.      (standard-fib (- x 2)))))
  1554.  
  1555. SHAR_EOF
  1556. #    End of shell archive
  1557. exit 0
  1558. -- 
  1559. Bob Page, U of Lowell CS Dept.  page@swan.ulowell.edu  ulowell!page
  1560. Have five nice days.
  1561.